home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / sort.t < prev    next >
Text File  |  1988-05-02  |  6KB  |  153 lines
  1. (herald sort (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; We gratefully acknowledge Bob Nix
  27.  
  28. ;;;  SORT:ONLINE-MERGE-SORT!
  29. ;;;  =======================
  30. ;;;  On-Line Merge sort, a fast and stable algorithm for sorting a list.
  31. ;;;  This is a very neat algorithm!  Consider the following code:
  32. ;;;
  33. ;;;    (DEFINE (MERGE-SORT L)
  34. ;;;        (IF (NULL? (CDR L))
  35. ;;;            L
  36. ;;;            (MERGE (MERGE-SORT (FIRST-HALF-OF L))
  37. ;;;                   (MERGE-SORT (SECOND-HALF-OF L)))))
  38. ;;;
  39. ;;;  The nested calls to MERGE above form a binary tree, with MERGE's of
  40. ;;;  singleton lists at the leaves, and a MERGE of two lists of size N/2 at
  41. ;;;  the top.  The algorithm below traverses this MERGE-tree in post-order,
  42. ;;;  moving from the lower left hand corner to the right.
  43. ;;;
  44. ;;;  This algorithm sorts N objects with about NlgN+2N comparisons and exactly
  45. ;;;  lgN conses.  The algorithm used is a version of mergesort that is
  46. ;;;  amenable to Lisp's data accessing primitives.  The first phase of the
  47. ;;;  algorithm is an "addition" phase in which each element X is added to
  48. ;;;  a list of lists of sorted runs B in much the same manner as a one is
  49. ;;;  added to a binary number.  If the first "digit" of B is 0, i.e. the first
  50. ;;;  list in B is NIL, then the element to be added becomes the first digit
  51. ;;;  of B.  If that digit is non empty then you merge the digit with X and
  52. ;;;  recurse on the rest of B -- setting the first digit of B to be zero.
  53. ;;;  For example:
  54. ;;;
  55. ;;;   Reversed      LIST B
  56. ;;;   Binary #     Each sublist is sorted.
  57. ;;;
  58. ;;;    0000        ()
  59. ;;;    1000        ((x))
  60. ;;;    0100        (()  (x x))
  61. ;;;    1100        ((x) (x x))
  62. ;;;    0010        (()  ()    (x x x x))
  63. ;;;    1010        ((x) ()    (x x x x))
  64. ;;;    0110        (()  (x x) (x x x x))
  65. ;;;    1110        ((x) (x x) (x x x x))
  66. ;;;    0001        (()  ()    ()        (x x x x x x x x))
  67. ;;;    1001        ((x) ()    ()        (x x x x x x x x))
  68. ;;;
  69. ;;;  The algorithm then merges the sublists of these lists into
  70. ;;;  one list, and returns that list.
  71. ;;;
  72. ;;;  To see the algorithm in action, trace LIST-MERGE!.
  73. ;;;
  74.  
  75. ;;; Returns list L sorted using OBJ-< for comparisons.
  76.  
  77. (define-integrable sort sort-list)
  78.  
  79. (define (sort-list l obj-<)
  80.   (cond ((or (null? l)
  81.              (null? (cdr l)))
  82.          l)
  83.         (else
  84.          (online-merge-sort! (copy-list l) obj-<))))
  85.  
  86. ;;; Returns list L sorted using OBJ-< for comparisons.
  87. ;;; L is destructively altered.
  88.  
  89. (define (sort-list! l obj-<)
  90.   (cond ((or (null? l)
  91.              (null? (cdr l)))
  92.          l)
  93.         (else
  94.          (online-merge-sort! l obj-<))))
  95.  
  96. ;;; The real sort procedure.  Elements of L are added to B, a list of sorted
  97. ;;; lists as defined above.  When all elements of L have been added to B
  98. ;;; the sublists of B are merged together to get the desired sorted list.
  99.  
  100. (define (online-merge-sort! l obj-<)
  101.   (let ((b (cons-from-freelist nil nil)))
  102.     (iterate loop ((l l))
  103.       (cond ((null? l)
  104.              (do ((c (cddr b) (cdr c))
  105.                   (r (cadr b) (list-merge! (car c) r obj-<)))
  106.                  ((null? c)
  107.                   (return-list-to-freelist b)
  108.                   r)))
  109.             (else
  110.              (let ((new-l (cdr l)))
  111.                (set (cdr l) nil)
  112.                (add-to-sorted-lists l b obj-<)
  113.                (loop new-l)))))))
  114.  
  115. ;;; X is a list that is merged into B, the list of sorted lists.
  116.  
  117. (define (add-to-sorted-lists x b obj-<)
  118.   (iterate loop ((x x) (b b))
  119.     (let ((l (cdr b)))
  120.       (cond ((null? l)
  121.              (set (cdr b) (cons-from-freelist x nil)))
  122.             ((null? (car l))
  123.              (set (car l) x))
  124.             (else
  125.              (let ((y (list-merge! x (car l) obj-<)))
  126.                 (set (car l) nil)
  127.                 (loop y l)))))))
  128.  
  129. ;;; Does a stable side-effecting merge of L1 and L2.
  130.  
  131. (define (list-merge! l1 l2 obj-<)
  132.   (cond ((null? l1) l2)
  133.         ((null? l2) l1)
  134.         ((obj-< (car l1) (car l2))
  135.          (real-list-merge! l2 (cdr l1) obj-< l1)
  136.          l1)
  137.         (else
  138.          (real-list-merge! l1 (cdr l2) obj-< l2)
  139.          l2)))
  140.  
  141. ;;; Does the real work of LIST-MERGE!.  L1 is assumed to be non-empty.
  142.  
  143. (define (real-list-merge! l1 l2 obj-< prev)
  144.   (iterate loop ((a l1) (b l2) (prev prev))
  145.     (cond ((null? b)
  146.            (set (cdr prev) a))
  147.           ((obj-< (car a) (car b))
  148.            (set (cdr prev) a)
  149.            (loop b (cdr a) a))
  150.           (else
  151.            (set (cdr prev) b)
  152.            (loop a (cdr b) b)))))
  153.